home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / manager.lisp < prev    next >
Lisp/Scheme  |  1991-11-08  |  33KB  |  785 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;; Window Manager Property functions
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package :xlib)
  22.  
  23. (defun wm-name (window)
  24.   (declare (type window window))
  25.   (declare (values string))
  26.   (get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char))
  27.  
  28. (defsetf wm-name (window) (name)
  29.   `(set-string-property ,window :WM_NAME ,name))
  30.  
  31. (defun set-string-property (window property string)
  32.   (declare (type window window)
  33.        (type keyword property)
  34.        (type stringable string))
  35.   (change-property window property (string string) :STRING 8 :transform #'char->card8)
  36.   string)
  37.  
  38. (defun wm-icon-name (window)
  39.   (declare (type window window))
  40.   (declare (values string))
  41.   (get-property window :WM_ICON_NAME :type :STRING
  42.         :result-type 'string :transform #'card8->char))
  43.  
  44. (defsetf wm-icon-name (window) (name)
  45.   `(set-string-property ,window :WM_ICON_NAME ,name))
  46.  
  47. (defun wm-client-machine (window)
  48.   (declare (type window window))
  49.   (declare (values string))
  50.   (get-property window :WM_CLIENT_MACHINE :type :STRING
  51.         :result-type 'string :transform #'card8->char))
  52.  
  53. (defsetf wm-client-machine (window) (name)
  54.   `(set-string-property ,window :WM_CLIENT_MACHINE ,name))
  55.  
  56. (defun get-wm-class (window)
  57.   (declare (type window window))
  58.   (declare (values (or null name-string) (or null class-string)))
  59.   (let ((value (get-property window :WM_CLASS :type :STRING
  60.                  :result-type 'string :transform #'card8->char)))
  61.     (declare (type (or null string) value))
  62.     (when value
  63.       (let* ((name-len (position #.(card8->char 0) (the string value)))
  64.          (name (subseq (the string value) 0 name-len))
  65.          (class (subseq (the string value) (1+ name-len) (1- (length value)))))
  66.     (values (and (plusp (length name)) name)
  67.         (and (plusp (length class)) class))))))
  68.  
  69. (defun set-wm-class (window resource-name resource-class)
  70.   (declare (type window window)
  71.        (type (or null stringable) resource-name resource-class))
  72.   (set-string-property window :WM_CLASS
  73.                (concatenate 'string
  74.                     (string (or resource-name ""))
  75.                     #.(make-string 1 :initial-element (card8->char 0))
  76.                     (string (or resource-class ""))
  77.                     #.(make-string 1 :initial-element (card8->char 0))))
  78.   (values))
  79.  
  80. (defun wm-command (window)
  81.   ;; Returns a list whose car is the command and 
  82.   ;; whose cdr is the list of arguments
  83.   (declare (type window window))
  84.   (declare (values list))
  85.   (do* ((command-string (get-property window :WM_COMMAND :type :STRING
  86.                       :result-type 'string :transform #'card8->char))
  87.     (command nil)
  88.     (start 0 (1+ end))
  89.     (end 0)
  90.     (len (length command-string)))
  91.        ((>= start len) (nreverse command))
  92.     (setq end (position #.(card8->char 0) command-string :start start))
  93.     (push (subseq command-string start end) command)))
  94.  
  95. (defsetf wm-command set-wm-command)
  96. (defun set-wm-command (window command)
  97.   ;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or
  98.   ;; equivalent), with elements of command separated by NULL characters.  This
  99.   ;; enables 
  100.   ;;   (with-standard-io-syntax (mapcar #'read-from-string (wm-command window)))
  101.   ;; to recover a lisp command.
  102.   (declare (type window window)
  103.        (type list command))
  104.   (set-string-property
  105.     window :WM_COMMAND
  106.     (with-output-to-string (stream)
  107.       (with-standard-io-syntax 
  108.     (dolist (c command)
  109.       (prin1 c stream)
  110.       (write-char #.(card8->char 0) stream)))))
  111.   command)
  112.  
  113. ;;-----------------------------------------------------------------------------
  114. ;; WM_HINTS
  115.  
  116. (def-clx-class (wm-hints)
  117.   (input nil :type (or null (member :off :on)))
  118.   (initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive)))
  119.   (icon-pixmap nil :type (or null pixmap))
  120.   (icon-window nil :type (or null window))
  121.   (icon-x nil :type (or null card16))
  122.   (icon-y nil :type (or null card16))
  123.   (icon-mask nil :type (or null pixmap))
  124.   (window-group nil :type (or null resource-id))
  125.   (flags 0 :type card32)    ;; Extension-hook.  Exclusive-Or'ed with the FLAGS field
  126.   ;; may be extended in the future
  127.   )
  128.  
  129. (defun wm-hints (window)
  130.   (declare (type window window))
  131.   (declare (values wm-hints))
  132.   (let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector)))
  133.     (when prop
  134.       (decode-wm-hints prop (window-display window)))))
  135.  
  136. (defsetf wm-hints set-wm-hints)
  137. (defun set-wm-hints (window wm-hints)
  138.   (declare (type window window)
  139.        (type wm-hints wm-hints))
  140.   (declare (values wm-hints))
  141.   (change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32)
  142.   wm-hints)
  143.  
  144. (defun decode-wm-hints (vector display)
  145.   (declare (type (simple-vector 9) vector)
  146.        (type display display))
  147.   (declare (values wm-hints))
  148.   (let ((input-hint 0)
  149.     (state-hint 1)
  150.     (icon-pixmap-hint 2)
  151.     (icon-window-hint 3)
  152.     (icon-position-hint 4)
  153.     (icon-mask-hint 5)
  154.     (window-group-hint 6))
  155.     (let ((flags (aref vector 0))
  156.       (hints (make-wm-hints))
  157.       (%buffer display))
  158.       (declare (type card32 flags)
  159.            (type wm-hints hints)
  160.            (type display %buffer))
  161.       (setf (wm-hints-flags hints) flags)
  162.       (when (logbitp input-hint flags)
  163.     (setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1))))
  164.       (when (logbitp state-hint flags)
  165.     (setf (wm-hints-initial-state hints)
  166.           (decode-type (member :dont-care :normal :zoom :iconic :inactive)
  167.                (aref vector 2))))
  168.       (when (logbitp icon-pixmap-hint flags)
  169.     (setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
  170.       (when (logbitp icon-window-hint flags)
  171.     (setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
  172.       (when (logbitp icon-position-hint flags)
  173.     (setf (wm-hints-icon-x hints) (aref vector 5)
  174.           (wm-hints-icon-y hints) (aref vector 6)))
  175.       (when (logbitp icon-mask-hint flags)
  176.     (setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
  177.       (when (and (logbitp window-group-hint flags) (> (length vector) 7))
  178.     (setf (wm-hints-window-group hints) (aref vector 8)))
  179.       hints)))
  180.  
  181.  
  182. (defun encode-wm-hints (wm-hints)
  183.   (declare (type wm-hints wm-hints))
  184.   (declare (values simple-vector))
  185.   (let ((input-hint         #b1)
  186.     (state-hint         #b10)
  187.     (icon-pixmap-hint   #b100)
  188.     (icon-window-hint   #b1000)
  189.     (icon-position-hint #b10000)
  190.     (icon-mask-hint     #b100000)
  191.     (window-group-hint  #b1000000)
  192.     (mask               #b1111111)
  193.     )
  194.     (let ((vector (make-array 9 :initial-element 0))
  195.       (flags 0))
  196.       (declare (type (simple-vector 9) vector)
  197.            (type card16 flags))
  198.       (when (wm-hints-input wm-hints)
  199.     (setf flags input-hint
  200.           (aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
  201.       (when (wm-hints-initial-state wm-hints)
  202.     (setf flags (logior flags state-hint)
  203.           (aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
  204.                        (wm-hints-initial-state wm-hints))))
  205.       (when (wm-hints-icon-pixmap wm-hints)
  206.     (setf flags (logior flags icon-pixmap-hint)
  207.           (aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
  208.       (when (wm-hints-icon-window wm-hints)
  209.     (setf flags (logior flags icon-window-hint)
  210.           (aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
  211.       (when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints))
  212.     (setf flags (logior flags icon-position-hint)
  213.           (aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
  214.           (aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
  215.       (when (wm-hints-icon-mask wm-hints)
  216.     (setf flags (logior flags icon-mask-hint)
  217.           (aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
  218.       (when (wm-hints-window-group wm-hints)
  219.     (setf flags (logior flags window-group-hint)
  220.           (aref vector 8) (wm-hints-window-group wm-hints)))
  221.       (setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask)))
  222.       vector)))
  223.  
  224. ;;-----------------------------------------------------------------------------
  225. ;; WM_SIZE_HINTS
  226.  
  227. (def-clx-class (wm-size-hints)
  228.   (user-specified-position-p nil :type boolean) ;; True when user specified x y
  229.   (user-specified-size-p nil :type boolean)     ;; True when user specified width height
  230.   (x nil :type (or null int16))            ;; Obsolete
  231.   (y nil :type (or null int16))            ;; Obsolete
  232.   (width nil :type (or null card16))        ;; Obsolete
  233.   (height nil :type (or null card16))        ;; Obsolete
  234.   (min-width nil :type (or null card16))
  235.   (min-height nil :type (or null card16))
  236.   (max-width nil :type (or null card16))
  237.   (max-height nil :type (or null card16))
  238.   (width-inc nil :type (or null card16))
  239.   (height-inc nil :type (or null card16))
  240.   (min-aspect nil :type (or null number))
  241.   (max-aspect nil :type (or null number))
  242.   (base-width nil :type (or null card16))
  243.   (base-height nil :type (or null card16))
  244.   (win-gravity nil :type (or null win-gravity))
  245.   (program-specified-position-p nil :type boolean) ;; True when program specified x y
  246.   (program-specified-size-p nil :type boolean)     ;; True when program specified width height
  247.   )
  248.  
  249.  
  250. (defun wm-normal-hints (window)
  251.   (declare (type window window))
  252.   (declare (values wm-size-hints))
  253.   (decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
  254.  
  255. (defsetf wm-normal-hints set-wm-normal-hints)
  256. (defun set-wm-normal-hints (window hints)
  257.   (declare (type window window)
  258.        (type wm-size-hints hints))
  259.   (declare (values wm-size-hints))
  260.   (change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
  261.   hints)
  262.  
  263. ;;; OBSOLETE
  264. (defun wm-zoom-hints (window)
  265.   (declare (type window window))
  266.   (declare (values wm-size-hints))
  267.   (decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
  268.  
  269. ;;; OBSOLETE
  270. (defsetf wm-zoom-hints set-wm-zoom-hints)
  271. ;;; OBSOLETE
  272. (defun set-wm-zoom-hints (window hints)
  273.   (declare (type window window)
  274.        (type wm-size-hints hints))
  275.   (declare (values wm-size-hints))
  276.   (change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
  277.   hints)
  278.  
  279. (defun decode-wm-size-hints (vector)
  280.   (declare (type (or null (simple-vector *)) vector))
  281.   (declare (values (or null wm-size-hints)))
  282.   (when vector
  283.     (let ((flags (aref vector 0))
  284.       (hints (make-wm-size-hints)))
  285.       (declare (type card16 flags)
  286.            (type wm-size-hints hints))
  287.       (setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags))
  288.       (setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags))
  289.       (setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags))
  290.       (setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags))
  291.       (when (logbitp 4 flags)
  292.     (setf (wm-size-hints-min-width hints) (aref vector 5)
  293.           (wm-size-hints-min-height hints) (aref vector 6)))
  294.       (when (logbitp 5 flags)
  295.     (setf (wm-size-hints-max-width hints) (aref vector 7)
  296.           (wm-size-hints-max-height hints) (aref vector 8)))
  297.       (when (logbitp 6 flags)
  298.     (setf (wm-size-hints-width-inc hints) (aref vector 9)
  299.           (wm-size-hints-height-inc hints) (aref vector 10)))
  300.       (when (logbitp 7 flags)
  301.     (setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12))
  302.           (wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14))))
  303.       (when (> (length vector) 15)
  304.     ;; This test is for backwards compatibility since old Xlib programs
  305.     ;; can set a size-hints structure that is too small.  See ICCCM.
  306.     (when (logbitp 8 flags)
  307.       (setf (wm-size-hints-base-width hints) (aref vector 15)
  308.         (wm-size-hints-base-height hints) (aref vector 16)))
  309.     (when (logbitp 9 flags)
  310.       (setf (wm-size-hints-win-gravity hints)
  311.         (decode-type (member-vector *win-gravity-vector*) (aref vector 17)))))
  312.       ;; Obsolete fields
  313.       (when (or (logbitp 0 flags) (logbitp 2 flags))
  314.     (setf (wm-size-hints-x hints) (aref vector 1)
  315.           (wm-size-hints-y hints) (aref vector 2)))
  316.       (when (or (logbitp 1 flags) (logbitp 3 flags))
  317.     (setf (wm-size-hints-width hints) (aref vector 3)
  318.           (wm-size-hints-height hints) (aref vector 4)))
  319.       hints)))
  320.  
  321. (defun encode-wm-size-hints (hints)
  322.   (declare (type wm-size-hints hints))
  323.   (declare (values simple-vector))
  324.   (let ((vector (make-array 18 :initial-element 0))
  325.     (flags 0))
  326.     (declare (type (simple-vector 18) vector)
  327.          (type card16 flags)) 
  328.     (when (wm-size-hints-user-specified-position-p hints)
  329.       (setf (ldb (byte 1 0) flags) 1))
  330.     (when (wm-size-hints-user-specified-size-p hints)
  331.       (setf (ldb (byte 1 1) flags) 1))
  332.     (when (wm-size-hints-program-specified-position-p hints)
  333.       (setf (ldb (byte 1 2) flags) 1))
  334.     (when (wm-size-hints-program-specified-size-p hints)
  335.       (setf (ldb (byte 1 3) flags) 1))
  336.     (when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints))
  337.       (setf (ldb (byte 1 4) flags) 1
  338.         (aref vector 5) (wm-size-hints-min-width hints)
  339.         (aref vector 6) (wm-size-hints-min-height hints)))
  340.     (when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints))
  341.       (setf (ldb (byte 1 5) flags) 1
  342.         (aref vector 7) (wm-size-hints-max-width hints)
  343.         (aref vector 8) (wm-size-hints-max-height hints)))
  344.     (when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints))
  345.       (setf (ldb (byte 1 6) flags) 1
  346.         (aref vector 9) (wm-size-hints-width-inc hints)
  347.         (aref vector 10) (wm-size-hints-height-inc hints)))
  348.     (let ((min-aspect (wm-size-hints-min-aspect hints))
  349.       (max-aspect (wm-size-hints-max-aspect hints)))
  350.       (when (and min-aspect max-aspect)
  351.     (setf (ldb (byte 1 7) flags) 1
  352.           min-aspect (rationalize min-aspect)
  353.           max-aspect (rationalize max-aspect)
  354.           (aref vector 11) (numerator min-aspect)
  355.           (aref vector 12) (denominator min-aspect)
  356.           (aref vector 13) (numerator max-aspect)
  357.           (aref vector 14) (denominator max-aspect))))
  358.     (when (and (wm-size-hints-base-width hints)
  359.            (wm-size-hints-base-height hints))
  360.       (setf (ldb (byte 1 8) flags) 1
  361.         (aref vector 15) (wm-size-hints-base-width hints)
  362.         (aref vector 16) (wm-size-hints-base-height hints)))
  363.     (when (wm-size-hints-win-gravity hints)
  364.       (setf (ldb (byte 1 9) flags) 1
  365.         (aref vector 17) (encode-type
  366.                    (member-vector *win-gravity-vector*)
  367.                    (wm-size-hints-win-gravity hints))))
  368.     ;; Obsolete fields
  369.     (when (and (wm-size-hints-x hints) (wm-size-hints-y hints)) 
  370.       (unless (wm-size-hints-user-specified-position-p hints)
  371.     (setf (ldb (byte 1 2) flags) 1))
  372.       (setf (aref vector 1) (wm-size-hints-x hints)
  373.         (aref vector 2) (wm-size-hints-y hints)))
  374.     (when (and (wm-size-hints-width hints) (wm-size-hints-height hints))
  375.       (unless (wm-size-hints-user-specified-size-p hints)
  376.     (setf (ldb (byte 1 3) flags) 1))
  377.       (setf (aref vector 3) (wm-size-hints-width hints)
  378.         (aref vector 4) (wm-size-hints-height hints)))
  379.     (setf (aref vector 0) flags)
  380.     vector))
  381.  
  382. ;;-----------------------------------------------------------------------------
  383. ;; Icon_Size
  384.  
  385. ;; Use the same intermediate structure as WM_SIZE_HINTS
  386.  
  387. (defun icon-sizes (window)
  388.   (declare (type window window))
  389.   (declare (values wm-size-hints))
  390.   (let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector)))
  391.     (declare (type (or null (simple-vector 6)) vector))
  392.     (when vector
  393.       (make-wm-size-hints
  394.     :min-width (aref vector 0)
  395.     :min-height (aref vector 1)
  396.     :max-width (aref vector 2)
  397.     :max-height (aref vector 3)
  398.     :width-inc (aref vector 4)
  399.     :height-inc (aref vector 5)))))
  400.   
  401. (defsetf icon-sizes set-icon-sizes)
  402. (defun set-icon-sizes (window wm-size-hints)
  403.   (declare (type window window)
  404.        (type wm-size-hints wm-size-hints))
  405.   (let ((vector (vector (wm-size-hints-min-width wm-size-hints)
  406.             (wm-size-hints-min-height wm-size-hints)
  407.             (wm-size-hints-max-width wm-size-hints)
  408.             (wm-size-hints-max-height wm-size-hints)
  409.             (wm-size-hints-width-inc wm-size-hints)
  410.             (wm-size-hints-height-inc wm-size-hints))))
  411.     (change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32)
  412.     wm-size-hints))
  413.  
  414. ;;-----------------------------------------------------------------------------
  415. ;; WM-Protocols
  416.  
  417. (defun wm-protocols (window)
  418.   (map 'list #'(lambda (id) (atom-name (window-display window) id))
  419.        (get-property window :WM_PROTOCOLS :type :ATOM)))
  420.  
  421. (defsetf wm-protocols set-wm-protocols)
  422. (defun set-wm-protocols (window protocols)
  423.   (change-property window :WM_PROTOCOLS
  424.            (map 'list #'(lambda (atom) (intern-atom (window-display window) atom))
  425.             protocols)
  426.            :ATOM 32)
  427.   protocols)
  428.  
  429. ;;-----------------------------------------------------------------------------
  430. ;; WM-Colormap-windows
  431.  
  432. (defun wm-colormap-windows (window)
  433.   (values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW
  434.             :transform #'(lambda (id)
  435.                        (lookup-window (window-display window) id)))))
  436.  
  437. (defsetf wm-colormap-windows set-wm-colormap-windows)
  438. (defun set-wm-colormap-windows (window colormap-windows)
  439.   (change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32
  440.            :transform #'window-id)
  441.   colormap-windows)
  442.  
  443. ;;-----------------------------------------------------------------------------
  444. ;; Transient-For
  445.  
  446. (defun transient-for (window)
  447.   (let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list)))
  448.     (and prop (lookup-window (window-display window) (car prop)))))
  449.  
  450. (defsetf transient-for set-transient-for)
  451. (defun set-transient-for (window transient)
  452.   (declare (type window window transient))
  453.   (change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32)
  454.   transient)
  455.  
  456. ;;-----------------------------------------------------------------------------
  457. ;; Set-WM-Properties
  458.  
  459. (defun set-wm-properties (window &rest options &key 
  460.               name icon-name resource-name resource-class command
  461.               client-machine hints normal-hints zoom-hints
  462.               ;; the following are used for wm-normal-hints
  463.               (user-specified-position-p nil usppp)
  464.               (user-specified-size-p nil usspp)
  465.               (program-specified-position-p nil psppp)
  466.               (program-specified-size-p nil psspp)
  467.               x y width height min-width min-height max-width max-height
  468.               width-inc height-inc min-aspect max-aspect
  469.               base-width base-height win-gravity
  470.               ;; the following are used for wm-hints
  471.               input initial-state icon-pixmap icon-window
  472.               icon-x icon-y icon-mask window-group)
  473.   ;; Set properties for WINDOW.
  474.   (declare (arglist window &rest options &key 
  475.            name icon-name resource-name resource-class command
  476.            client-machine hints normal-hints
  477.            ;; the following are used for wm-normal-hints
  478.            user-specified-position-p user-specified-size-p
  479.            program-specified-position-p program-specified-size-p
  480.            min-width min-height max-width max-height
  481.            width-inc height-inc min-aspect max-aspect
  482.            base-width base-height win-gravity
  483.            ;; the following are used for wm-hints
  484.            input initial-state icon-pixmap icon-window
  485.            icon-x icon-y icon-mask window-group))
  486.   (declare (type window window)
  487.        (type (or null stringable) name icon-name resource-name resource-class client-machine)
  488.        (type (or null list) command)
  489.        (type (or null wm-hints) hints)
  490.        (type (or null wm-size-hints) normal-hints zoom-hints)
  491.        (type boolean user-specified-position-p user-specified-size-p)
  492.        (type boolean program-specified-position-p program-specified-size-p)
  493.        (type (or null int16) x y)
  494.        (type (or null card16) width height min-width min-height max-width max-height width-inc height-inc base-width base-height)
  495.        (type (or null win-gravity) win-gravity)
  496.        (type (or null number) min-aspect max-aspect)
  497.        (type (or null (member :off :on)) input)
  498.        (type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state)
  499.        (type (or null pixmap) icon-pixmap icon-mask)
  500.        (type (or null window) icon-window)
  501.        (type (or null card16) icon-x icon-y)
  502.        (type (or null resource-id) window-group)
  503.        (dynamic-extent options))
  504.   (when name (setf (wm-name window) name))
  505.   (when icon-name (setf (wm-icon-name window) icon-name))
  506.   (when client-machine (setf (wm-client-machine window) client-machine))
  507.   (when (or resource-name resource-class)
  508.     (set-wm-class window resource-name resource-class))
  509.   (when command (setf (wm-command window) command))
  510.   ;; WM-HINTS
  511.   (if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window
  512.                 :icon-x :icon-y :icon-mask :window-group))
  513.     (when (getf options arg) (return t)))
  514.       (let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints))))
  515.     (when input (setf (wm-hints-input wm-hints) input))
  516.     (when initial-state (setf (wm-hints-initial-state wm-hints) initial-state))
  517.     (when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap))
  518.     (when icon-window (setf (wm-hints-icon-window wm-hints) icon-window))
  519.     (when icon-x (setf (wm-hints-icon-x wm-hints) icon-x))
  520.     (when icon-y (setf (wm-hints-icon-y wm-hints) icon-y))
  521.     (when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask))
  522.     (when window-group
  523.       (setf (wm-hints-window-group wm-hints) window-group))
  524.     (setf (wm-hints window) wm-hints))
  525.       (when hints (setf (wm-hints window) hints)))
  526.   ;; WM-NORMAL-HINTS
  527.   (if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height
  528.             :width-inc :height-inc :min-aspect :max-aspect
  529.             :user-specified-position-p :user-specified-size-p
  530.             :program-specified-position-p :program-specified-size-p
  531.             :base-width :base-height :win-gravity))
  532.     (when (getf options arg) (return t)))
  533.       (let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints))))
  534.     (when x (setf (wm-size-hints-x size) x))
  535.     (when y (setf (wm-size-hints-y size) y))
  536.     (when width (setf (wm-size-hints-width size) width))
  537.     (when height (setf (wm-size-hints-height size) height))
  538.     (when min-width (setf (wm-size-hints-min-width size) min-width))
  539.     (when min-height (setf (wm-size-hints-min-height size) min-height))
  540.     (when max-width (setf (wm-size-hints-max-width size) max-width))
  541.     (when max-height (setf (wm-size-hints-max-height size) max-height))
  542.     (when width-inc (setf (wm-size-hints-width-inc size) width-inc))
  543.     (when height-inc (setf (wm-size-hints-height-inc size) height-inc))
  544.     (when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect))
  545.     (when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect))
  546.     (when base-width (setf (wm-size-hints-base-width size) base-width))
  547.     (when base-height (setf (wm-size-hints-base-height size) base-height))
  548.     (when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity))
  549.     (when usppp
  550.       (setf (wm-size-hints-user-specified-position-p size) user-specified-position-p))
  551.     (when usspp
  552.       (setf (wm-size-hints-user-specified-size-p size) user-specified-size-p))
  553.     (when psppp
  554.       (setf (wm-size-hints-program-specified-position-p size) program-specified-position-p))
  555.     (when psspp
  556.       (setf (wm-size-hints-program-specified-size-p size) program-specified-size-p))
  557.     (setf (wm-normal-hints window) size))
  558.       (when normal-hints (setf (wm-normal-hints window) normal-hints)))
  559.   (when zoom-hints (setf (wm-zoom-hints window) zoom-hints))
  560.   )
  561.  
  562. ;;; OBSOLETE
  563. (defun set-standard-properties (window &rest options)
  564.   (declare (dynamic-extent options))
  565.   (apply #'set-wm-properties window options))
  566.  
  567. ;;-----------------------------------------------------------------------------
  568. ;; WM Control
  569.  
  570. (defun iconify-window (window screen)
  571.   (declare (type window window)
  572.        (type screen screen))
  573.   (let ((root (screen-root screen)))
  574.     (declare (type window root))
  575.     (send-event root :client-message '(:substructure-redirect :substructure-notify)
  576.         :window window :format 32 :type :WM_CHANGE_STATE :data (list 3))))
  577.  
  578. (defun withdraw-window (window screen)
  579.   (declare (type window window)
  580.        (type screen screen))
  581.   (unmap-window window)
  582.   (let ((root (screen-root screen)))
  583.     (declare (type window root))
  584.     (send-event root :unmap-notify '(:substructure-redirect :substructure-notify)
  585.         :window window :event-window root :configure-p nil)))
  586.  
  587.  
  588. ;;-----------------------------------------------------------------------------
  589. ;; Colormaps
  590.  
  591. (def-clx-class (standard-colormap (:copier nil) (:predicate nil))
  592.   (colormap nil :type (or null colormap))
  593.   (base-pixel 0 :type pixel)
  594.   (max-color nil :type (or null color))
  595.   (mult-color nil :type (or null color))
  596.   (visual nil :type (or null visual-info))
  597.   (kill nil :type (or (member nil :release-by-freeing-colormap)
  598.               drawable gcontext cursor colormap font)))
  599.  
  600. (defun rgb-colormaps (window property)
  601.   (declare (type window window)
  602.        (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
  603.              :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
  604.   (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
  605.     (declare (type (or null simple-vector) prop))
  606.     (when prop
  607.       (list (make-standard-colormap
  608.           :colormap (lookup-colormap (window-display window) (aref prop 0))
  609.           :base-pixel (aref prop 7)
  610.           :max-color (make-color :red   (card16->rgb-val (aref prop 1))
  611.                      :green (card16->rgb-val (aref prop 3))
  612.                      :blue  (card16->rgb-val (aref prop 5)))
  613.           :mult-color (make-color :red   (card16->rgb-val (aref prop 2))
  614.                       :green (card16->rgb-val (aref prop 4))
  615.                       :blue  (card16->rgb-val (aref prop 6)))
  616.           :visual (and (<= 9 (length prop))
  617.                (visual-info (window-display window) (aref prop 8)))
  618.           :kill (and (<= 10 (length prop))
  619.              (let ((killid (aref prop 9)))
  620.                (if (= killid 1)
  621.                    :release-by-freeing-colormap
  622.                    (lookup-resource-id (window-display window) killid)))))))))
  623.  
  624. (defsetf rgb-colormaps set-rgb-colormaps)
  625. (defun set-rgb-colormaps (window property maps)
  626.   (declare (type window window)
  627.        (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
  628.              :RGB_GREEN_MAP :RGB_BLUE_MAP) property)
  629.        (type list maps))
  630.   (let ((prop (make-array (* 10 (length maps)) :element-type 'card32))
  631.     (index -1))
  632.     (dolist (map maps)
  633.       (setf (aref prop (incf index))
  634.         (encode-type colormap (standard-colormap-colormap map)))
  635.       (setf (aref prop (incf index))
  636.         (encode-type rgb-val (color-red (standard-colormap-max-color map))))
  637.       (setf (aref prop (incf index))
  638.         (encode-type rgb-val (color-red (standard-colormap-mult-color map))))
  639.       (setf (aref prop (incf index))
  640.         (encode-type rgb-val (color-green (standard-colormap-max-color map))))
  641.       (setf (aref prop (incf index))
  642.         (encode-type rgb-val (color-green (standard-colormap-mult-color map))))
  643.       (setf (aref prop (incf index))
  644.         (encode-type rgb-val (color-blue (standard-colormap-max-color map))))
  645.       (setf (aref prop (incf index))
  646.         (encode-type rgb-val (color-blue (standard-colormap-mult-color map))))
  647.       (setf (aref prop (incf index))
  648.         (standard-colormap-base-pixel map))
  649.       (setf (aref prop (incf index))
  650.         (visual-info-id (standard-colormap-visual map)))
  651.       (setf (aref prop (incf index))
  652.         (let ((kill (standard-colormap-kill map)))
  653.           (etypecase kill
  654.         (symbol
  655.           (ecase kill
  656.             ((nil) 0)
  657.             ((:release-by-freeing-colormap) 1)))
  658.         (drawable (drawable-id kill))
  659.         (gcontext (gcontext-id kill))
  660.         (cursor (cursor-id kill))
  661.         (colormap (colormap-id kill))
  662.         (font (font-id kill))))))
  663.     (change-property window property prop :RGB_COLOR_MAP 32)))
  664.  
  665. ;;; OBSOLETE
  666. (defun get-standard-colormap (window property)
  667.   (declare (type window window)
  668.        (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
  669.              :RGB_GREEN_MAP :RGB_BLUE_MAP) property))
  670.   (declare (values colormap base-pixel max-color mult-color))
  671.   (let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
  672.     (declare (type (or null simple-vector) prop))
  673.     (when prop
  674.       (values (lookup-colormap (window-display window) (aref prop 0))
  675.           (aref prop 7)            ;Base Pixel
  676.           (make-color :red   (card16->rgb-val (aref prop 1))    ;Max Color
  677.               :green (card16->rgb-val (aref prop 3))
  678.               :blue  (card16->rgb-val (aref prop 5)))
  679.           (make-color :red   (card16->rgb-val (aref prop 2))    ;Mult color
  680.               :green (card16->rgb-val (aref prop 4))
  681.               :blue  (card16->rgb-val (aref prop 6)))))))
  682.  
  683. ;;; OBSOLETE
  684. (defun set-standard-colormap (window property colormap base-pixel max-color mult-color)
  685.   (declare (type window window)
  686.        (type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
  687.              :RGB_GREEN_MAP :RGB_BLUE_MAP) property)
  688.        (type colormap colormap)
  689.        (type pixel base-pixel)
  690.        (type color max-color mult-color))
  691.   (let ((prop (apply #'vector (encode-type colormap colormap)
  692.              (encode-type rgb-val (color-red max-color))
  693.              (encode-type rgb-val (color-red mult-color))
  694.              (encode-type rgb-val (color-green max-color))
  695.              (encode-type rgb-val (color-green mult-color))
  696.              (encode-type rgb-val (color-blue max-color))
  697.              (encode-type rgb-val (color-blue mult-color))
  698.              base-pixel)))
  699.     (change-property window property prop :RGB_COLOR_MAP 32)))
  700.  
  701. ;;-----------------------------------------------------------------------------
  702. ;; Cut-Buffers
  703.  
  704. (defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string)
  705.            (transform #'card8->char) (start 0) end)
  706.   ;; Return the contents of cut-buffer BUFFER
  707.   (declare (type display display)
  708.        (type (integer 0 7) buffer)
  709.        (type xatom type)
  710.        (type array-index start)
  711.        (type (or null array-index) end)
  712.        (type t result-type)            ;a sequence type
  713.        (type (or null (function (integer) t)) transform))
  714.   (declare (values sequence type format bytes-after))
  715.   (let* ((root (screen-root (first (display-roots display))))
  716.      (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
  717.                 :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
  718.              buffer)))
  719.     (get-property root property :type type :result-type result-type
  720.           :start start :end end :transform transform)))
  721.  
  722. ;; Implement the following:
  723. ;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8)
  724. ;;                    (transform #'char->card8) (start 0) end) (data)
  725. ;; In order to avoid having to pass positional parameters to set-cut-buffer,
  726. ;; We've got to do the following.  WHAT A PAIN...
  727. #-clx-ansi-common-lisp
  728. (define-setf-method cut-buffer (display &rest option-list)
  729.   (declare (dynamic-extent option-list))
  730.   (do* ((options (copy-list option-list))
  731.     (option options (cddr option))
  732.     (store (gensym))
  733.     (dtemp (gensym))
  734.     (temps (list dtemp))
  735.     (values (list display)))
  736.        ((endp option)
  737.     (values (nreverse temps)
  738.         (nreverse values)
  739.         (list store)
  740.         `(set-cut-buffer ,store ,dtemp ,@options)
  741.         `(cut-buffer ,@options)))
  742.     (unless (member (car option) '(:buffer :type :format :start :end :transform))
  743.       (error "Keyword arg ~s isn't recognized" (car option)))
  744.     (let ((x (gensym)))
  745.       (push x temps)
  746.       (push (cadr option) values)
  747.       (setf (cadr option) x))))
  748.  
  749. (defun
  750.   #+clx-ansi-common-lisp (setf cut-buffer)
  751.   #-clx-ansi-common-lisp set-cut-buffer
  752.   (data display &key (buffer 0) (type :STRING) (format 8)
  753.     (start 0) end (transform #'char->card8))
  754.   (declare (type sequence data)
  755.        (type display display)
  756.        (type (integer 0 7) buffer)
  757.        (type xatom type)
  758.        (type (member 8 16 32) format)
  759.        (type array-index start)
  760.        (type (or null array-index) end)
  761.        (type (or null (function (integer) t)) transform))
  762.   (let* ((root (screen-root (first (display-roots display))))
  763.      (property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
  764.                      :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
  765.              buffer)))
  766.     (change-property root property data type format :transform transform :start start :end end)
  767.     data))
  768.  
  769. (defun rotate-cut-buffers (display &optional (delta 1) (careful-p t))
  770.   ;; Positive rotates left, negative rotates right (opposite of actual protocol request).
  771.   ;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors.
  772.   (declare (type display display)
  773.        (type int16 delta)
  774.        (type boolean careful-p))
  775.   (let* ((root (screen-root (first (display-roots display))))
  776.      (buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
  777.              :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)))
  778.     (when careful-p
  779.       (let ((props (list-properties root)))
  780.     (dotimes (i 8)
  781.       (unless (member (aref buffers i) props)
  782.         (setf (cut-buffer display :buffer i) "")))))
  783.     (rotate-properties root buffers delta)))
  784.  
  785.